home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
plx13.zip
/
WOPLUS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-10-13
|
14KB
|
560 lines
{WOPLUS - Extensions to ObjectWindows Copyright (C) Doug Overmyer 7/1/91}
unit WOPlus;
{$R woplus.res}
{******************************************************************}
{ I N T E R F A C E }
{******************************************************************}
interface
uses WinTypes, WinProcs, WinDos, Strings, WObjects,StdDlgs,
Printer1,WFPlus;
const
sr_Recessed = 1;
sr_Raised = 0;
type
PODButton = ^TODButton;
TODButton = object(TButton)
HBmp :HBitmap;
State:Integer;
constructor Init(AParent:PWindowsObject; AnID:Integer;ATitle:PChar;
X,Y,W,H:Integer;IsDefault:Boolean;BMP:PChar);
destructor Done;virtual;
procedure DrawItem(var Msg:TMessage);virtual;
end;
type
PTextObj = ^TTextObj;
TTextObj = object(TObject)
Text:PChar;
constructor Init(NewText:PChar);
destructor Done;virtual;
end;
type
PIntObj = ^TIntObj;
TIntObj = object(TObject)
Int:Integer;
constructor Init(NewInt:Integer);
destructor Done;virtual;
end;
type
PStack = ^TStack;
TStack = object(TCollection)
procedure Push(Item:Pointer);virtual;
function Pop:Pointer;virtual;
end;
{TTextStream}
type
PTextStream = ^TTextStream ;
TTextStream = object(TBufStream)
CharsToRead : LongInt;
CharsRead : LongInt;
ARecord :PChar;
constructor Init(FileName:PChar;Mode,Size:Word);
destructor Done;virtual;
function GetNext:PChar;virtual;
function WriteNext(szARecord:PChar):integer;virtual;
function WriteEOF:integer;virtual;
function IsEOF:Boolean;virtual;
function GetPctDone:Integer;
end;
{TMeter}
type
PMeterWindow = ^TMeterWindow;
TMeterWindow = object(TWindow)
TheRedBrush:HBrush;
TheGrayBrush:Hbrush;
ThePen:HPen;
X,Y,dX,dY,mX :Integer;
PctDone :Integer;
Icon:HIcon;
constructor Init(AParent:PWindowsObject;ATitle:PChar);
procedure SetupWindow;virtual;
destructor Done; virtual;
procedure Draw(NewPctDone:Integer);virtual;
procedure Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);virtual;
end;
type {Printer object support for margins,fonts}
PWOPrinter = ^TWOPrinter;
TWOPrinter = object(tPrinter1)
end;
type
PSRect = ^TSRect;
TSRect = object(TWindow)
W,H:Integer;
State:Integer;
constructor Init(AParent:PWindowsObject;AnID:Integer; ATitle:PChar;
NewX,NewY,NewW,NewH:Integer; NewState:Integer);
destructor Done;virtual;
procedure Paint(PaintDC:HDC; var PaintInfo:TPaintStruct);virtual;
procedure SetupWindow;virtual;
end;
type
PSText = ^TSText;
TSText = object(TSRect)
Text:Array [0..80] of Char;
DTStyle:Integer;
constructor Init(AParent:PWindowsObject;AnID:Integer; ATitle:PChar;
NewX,NewY,NewW,NewH:Integer; NewState,NewStyle:Integer);
destructor Done;virtual;
procedure Paint(PaintDC:HDC; var PaintInfo:TPaintStruct);virtual;
procedure SetText(NewText:PChar);virtual;
end;
{********************************************************************}
{I M P L E M E N T A T I O N }
{********************************************************************}
implementation
{********************************************************************}
constructor TODButton.Init(AParent:PWindowsObject; AnID:Integer;ATitle:PChar;
X,Y,W,H:Integer;IsDefault:Boolean;BMP:PChar);
begin
TButton.Init(AParent,AnID,ATitle,X,Y,W,H,IsDefault);
Attr.Style := Attr.Style or bs_OwnerDraw;
HBmp := LoadBitmap(HInstance,BMP);
end;
destructor TODButton.Done;
begin
TButton.Done;
DeleteObject(HBmp);
end;
procedure TODButton.DrawItem(var Msg:TMessage);
var
TheDC:HDc;
ThePen:HPen;
Pen1:HPen;
Pen2:HPen;
TheBrush :HBrush;
OldBrush :HBrush;
OldPen:HPen;
OldBitMap:HBitMap;
MemDC :HDC;
LPts:Array[0..2] of TPoint;
RPts:Array[0..2] of TPoint;
PDIS :^TDrawItemStruct;
X,Y,W,H:Integer;
begin
PDIS := Pointer(Msg.lParam);
if PDIS^.itemAction = oda_Focus then Exit;
if ((PDIS^.itemAction and oda_Select ) > 0) and
((PDIS^.itemState and ods_Selected) > 0) then
State := 1 else State := 0; ;
X := PDIS^.rcItem.left;Y := PDIS^.rcItem.top;
W := PDIS^.rcItem.right-PDIS^.rcItem.left;
H := PDIS^.rcItem.bottom-PDIS^.rcItem.top;
LPts[0].x := W; LPts[0].y := 0;
LPts[1].x := 0; LPts[1].y := 0;
LPts[2].x := 0; LPts[2].y := H;
RPts[0].x := 0; RPts[0].y := H;
RPts[1].x := W; RPts[1].y := H;
RPts[2].x := W; RPts[2].y := 0;
MemDC := CreateCompatibleDC(PDIS^.HDC);
OldBitMap := SelectObject(MemDC,HBMP);
if State = 0 then
BitBlt(PDIS^.HDC,X,Y,W,H, MemDC,0,0,SrcCopy)
else
BitBlt(PDIS^.HDC,X+2,Y+2,W,H, MemDC,0,0,SrcCopy);
SelectObject(MemDC,OldBitMap);
DeleteDC(MemDC);
Pen1 := CreatePen(ps_Solid,2,$00000000);
OldPen := SelectObject(PDIS^.HDC,Pen1);
PolyLine(PDIS^.HDC,LPts,3);
PolyLine(PDIS^.HDC,RPts,3);
SelectObject(PDIS^.HDC,OldPen);
DeleteObject(Pen1);
LPts[0].x := W-2; LPts[0].y := 2;
LPts[1].x := 2; LPts[1].y := 2;
LPts[2].x := 2;LPts[2].y := H-2;
RPts[0].x := 1; RPts[0].y := H-1;
RPts[1].x := W-1; RPts[1].y := H-1;
RPts[2].x := W-1; RPts[2].y := 1;
if State = 0 then
begin
Pen1 := CreatePen(ps_Solid,2,$00FFFFFF);
Pen2 := CreatePen(ps_Solid,2,$00808080);
end
else
begin
Pen2 := CreatePen(ps_Solid,1,$00808080);
Pen1 := CreatePen(ps_Solid,2,$00808080);
end;
OldPen := SelectObject(PDIS^.HDC,Pen1);
PolyLine(PDIS^.HDC,LPts,3);
SelectObject(PDIS^.HDC,Pen2);
DeleteObject(Pen1);
PolyLine(PDIS^.HDC,RPts,3);
SelectObject(PDIS^.HDC,OldPen);
DeleteObject(Pen2);
end;
{***********************************************************************}
constructor TTextObj.Init(NewText:PChar);
begin
Text := StrNew(NewText);
end;
destructor TTextObj.Done;
begin
StrDispose(Text);
end;
{***********************************************************************}
constructor TIntObj.Init(NewInt:Integer);
begin
Int := NewInt;
end;
destructor TIntObj.Done;
begin
end;
{***********************************************************************}
procedure TStack.Push(Item:Pointer);
begin
AtInsert(0,Item);
end;
function TStack.Pop:Pointer;
begin
Pop := At(0);
AtDelete(0);
end;
{***********************************************************************}
{TTextStream Methods}
constructor TTextStream.Init(FileName:PChar; Mode,Size:Word);
begin
TBufStream.Init(FileName,Mode,Size);
CharsRead := 0;
CharsToRead := TBufStream.GetSize;
ARecord := MemAlloc(32000);
end;
{Done}
destructor TTextStream.Done;
begin
TBufStream.Done;
FreeMem(ARecord,32000);
end;
{GetNext} {replace unwanted control chars with spaces 10/5/91}
function TTextStream.GetNext:PChar;
var
Blksize:Integer;
AChar:Char;
Indx : Integer;
IsEOR : Boolean;
begin
Indx := 0;
IsEOR := False;
ARecord[0] := #0;
while (CharsRead < CharsToRead) and (IsEOR = False) do
begin
TBufStream.Read(AChar,1);
Inc(CharsRead);
case AChar of
#13:
begin
ARecord[Indx] := #0;
IsEOR := True;
end;
#26:
begin
if Indx > 0 then
begin
ARecord[Indx] := #0;
IsEOR := True;
end;
end;
#10:
begin
end;
#9:
begin
ARecord[Indx] := AChar;
Inc(Indx);
end;
#0..#31:
begin
ARecord[Indx] := ' ';
Inc(Indx);
end;
else
begin
ARecord[Indx] := AChar;
inc(Indx);
end;
end;
end;
ARecord[Indx] := #0;
GetNext := ARecord;
end;
{WriteNext}
{This method not actually used due to performance loss - instead
TStream.Write is called directly}
function TTextStream.WriteNext(szARecord:PChar):Integer;
const
CRLF : Array[0..2] of Char = #13#10#0;
begin
TBufStream.Write(szARecord,
StrLen(szARecord));
TBufStream.Write(CRLF,2);
WriteNext := StrLen(szARecord);
end;
{WriteEOF}
function TTextStream.WriteEOF:Integer;
const
EOF : Array[0..1] of Char = #26;
begin
TBufStream.Write(EOF,1);
WriteEOF := 1;
end;
{IsEOF}
function TTextStream.IsEOF:Boolean;
begin
IsEOF := False;
if CharsRead >= CharsToRead then
IsEOF := True;
end;
{GetPctDone}
function TTextStream.GetPctDone:Integer;
begin
GetPctDone := CharsRead*100 div CharsToRead;
end;
{**********************************************************************}
{TMeterWindow Methods}
{Init}
constructor TMeterWindow.Init(Aparent:PWindowsObject;ATitle:PChar);
begin
TWindow.Init(AParent,ATitle);
DisableAutoCreate;
ThePen := CreatePen(ps_Solid,0,$00000000);
TheGrayBrush := CreateSolidBrush($00C0C0C0);
TheRedBrush := CreateSolidBrush(RGB(255,0,0));
with Attr do
begin
X := 100;Y :=100 ;W := 350;H := 95;
Style := ws_Popup or ws_Visible or ws_Border or ws_Caption;
end;
X := 50;
Y := 10;
dX := 275;
dY := 30;
mX := 50; {midpoint between X & X+dX}
PctDone := 0;
end;
procedure TMeterWindow.SetupWindow;
begin
TWindow.SetupWindow;
Icon :=LoadIcon(HInstance,'WOP_Icon1');
end;
{Done}
destructor TMeterWindow.Done;
begin
DeleteObject(TheGrayBrush);
DeleteObject(TheRedBrush);
DeleteObject(ThePen);
Destroy;
TWindow.Done;
end;
procedure TMeterWindow.Draw(NewPctDone:Integer);
var
Rgn:TRect;
begin
PctDone := NewPctDone;
If PctDone > 0 then
mX := X + ((dX * PctDone) div 100)
else
mX := X;
Rgn.Left := X;
Rgn.Top := Y;
Rgn.Right := Max(210,mx);
Rgn.Bottom := Y+dY+20;
InvalidateRect(HWindow,@Rgn,false);
UpdateWindow(HWindow);
end;
procedure TMeterWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
var
OldBrush : HBrush;
OldPen :HPen;
OldColor : LongInt;
OldBkMode : Integer;
Buf : Array[0..6] of Char;
begin
DrawIcon(PaintDC,10,10,Icon);
OldPen := SelectObject(PaintDC,ThePen);
OldBrush := SelectObject(PaintDC,TheGrayBrush);
Rectangle(PaintDC,X,Y,mX,Y+dY);
Str(PctDone:2, Buf);
StrCat(Buf,'%');
SetTextAlign(PaintDC,ta_left);
OldColor := SetTextColor(PaintDC,RGB(255,0,0)); {Red}
{OldBkMode := SetBkMode(PaintDC,Transparent);}
TextOut(PaintDC,180,42,Buf,StrLen(Buf));
SelectObject(PaintDC,OldBrush);
SelectObject(PaintDC,OldPen);
SetTextColor(PaintDC,Oldcolor);
{SetBkMode(PaintDC,OldBkMode);}
end;
{***********************************************************************}
constructor TSRect.Init(AParent:PWindowsObject; AnID:Integer;
ATitle:PChar; NewX,NewY,NewW,NewH:Integer; NewState:Integer);
begin
TWindow.Init(AParent,ATitle);
Attr.Style := ws_Child or ws_visible ;
Attr.X := NewX;
Attr.Y := NewY;
Attr.W := NewW;
Attr.H := NewH;
Attr.ID := AnID;
W := NewW;
H := NewH;
if NewState = sr_Recessed then
State := sr_Recessed
else
State := sr_Raised;
end;
destructor TSRect.Done;
begin
TWindow.Done;
end;
procedure TSRect.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
var
LPts:Array[0..2] of TPoint;
RPts:Array[0..2] of TPoint;
ThePen:HPen;
Pen1:HPen;
Pen2:HPen;
TheBrush :HBrush;
OldBrush :HBrush;
OldPen:HPen;
OldBkMode:Integer;
DRect:TRect;
Ofs:Integer;
begin
TheBrush := GetStockObject(ltGray_Brush); {Draw window background}
OldBrush := SelectObject(PaintDC,TheBrush);
Rectangle(PaintDC,0,0,W,H);
SelectObject(PaintDC,OldBrush);
Ofs := 0;
LPts[0].x := Ofs; LPts[0].y := H-Ofs;
LPts[1].x := Ofs; LPts[1].y := Ofs;
LPts[2].x := W-Ofs; LPts[2].y := Ofs;
RPts[0].x := Ofs; RPts[0].y := H-Ofs;
RPts[1].x := W-Ofs; RPts[1].y := H-Ofs;
RPts[2].x := W-Ofs; RPts[2].y := Ofs;
Pen1 := CreatePen(ps_Solid,1,$00000000); {Draw a surrounding blk frame}
OldPen := SelectObject(PaintDC,Pen1);
PolyLine(PaintDC,LPts,3);
PolyLine(PaintDC,RPts,3);
SelectObject(PaintDC,OldPen);
DeleteObject(Pen1);
Ofs := 1;
LPts[0].x := Ofs; LPts[0].y := H-Ofs;
LPts[1].x := Ofs; LPts[1].y := Ofs;
LPts[2].x := W-Ofs; LPts[2].y := Ofs;
RPts[0].x := Ofs; RPts[0].y := H-Ofs;
RPts[1].x := W-Ofs; RPts[1].y := H-Ofs;
RPts[2].x := W-Ofs; RPts[2].y := Ofs;
if State = sr_Raised then
begin
Pen1 := CreatePen(ps_Solid,1,$00FFFFFF);
Pen2 := CreatePen(ps_Solid,1,$00808080);
end
else
begin
Pen1 := CreatePen(ps_Solid,1,$00808080);
Pen2 := CreatePen(ps_Solid,1,$00FFFFFF);
end;
OldPen := SelectObject(PaintDC,Pen1); {Draw the highlights}
PolyLine(PaintDC,LPts,3);
SelectObject(PaintDC,Pen2);
DeleteObject(Pen1);
PolyLine(PaintDC,RPts,3);
SelectObject(PaintDC,OldPen);
DeleteObject(Pen2);
end;
procedure TSRect.SetupWindow;
begin
end;
{***********************************************************************}
constructor TSText.Init(AParent:PWindowsObject; AnID:Integer;
ATitle:PChar; NewX,NewY,NewW,NewH:Integer; NewState,NewStyle:Integer);
begin
TSRect.Init(AParent,AnID,ATitle,NewX,NewY,NewW,NewH,NewState);
DTStyle := NewStyle;
StrCopy(Text,ATitle);
end;
destructor TSText.Done;
begin
TSRect.Done;
end;
procedure TSText.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
var
OldBkMode:Integer;
DRect:TRect;
begin
TSRect.Paint(PaintDC,PaintInfo);
OldBkMode := SetBkMode(PaintDC,Transparent); {Draw the text}
DRect.left := 3;DRect.Top := 2;DRect.right := W-3;DRect.Bottom := H-2;
DrawText(PaintDC,Text,StrLen(Text),DRect,DTStyle);
SetBkMode(PaintDC,OldBkMode);
end;
procedure TSText.SetText(NewText:PChar);
var
DRect:TRect;
begin
StrCopy(Text,NewText);
DRect.left := 3;DRect.Top := 2;DRect.right := W-3;DRect.Bottom := H-2;
InvalidateRect(HWindow,@DRect,false);
end;
end.